;;;;
;;;; PREPROCESSING OF CLASS AND MEMBER DECLARATIONS TO "WIRE" THEIR TYPES
;;;;

(define (prewire-types classdef)
  (define classname (name classdef))
  (define new-type
    (maybe-make-user-type (name (name classdef))
			  (type-expression-value (parent classdef))))
  (define constructor-args (initargs classdef))

  (set (current-value classname) new-type)
  (set (type base) 
       (type-expression-value (parent classdef)))
  (wire-type! classname type-type)
  (for-each (lambda (m)
	      (now-compiling
	       m
	       (lambda ()
		 (define v (var m))
		 (define n (native-name m))
		 (define k (keywords m))
		 (define t (rtype m))
		 (define val (value m))

		 (if (is? val lambda-expression)
		     (prewire-method-types v n k t val new-type)
		     (prewire-field-types v n k t val new-type)))))
	    (members classdef))
  (when constructor-args
    (set (constructor-arg-types new-type)
	 (map (lambda (field)
		(define t (type field))
		(unless (is? t procedure-type)
		  (error "Constructor argument isn't a field name" (unparse field)))
		(result t))
	      constructor-args))))

(define (maybe-make-user-type cname parent)
  (define old-definition (current-value (parse cname)))
  (if (and (is? old-definition type-class)
	   (eq? (name old-definition) cname)
	   (eq? (cadr (supertypes old-definition))
		parent))
      old-definition
      (simple-make-user-type cname parent)))
	 

(define (static-keys? keys)
  (and keys
       (memq 'static keys)))

(define (prewire-method-types var native keys typeexp value class-type)
  (define static? (static-keys? keys))
  (let* ((args (variables value))
	 (thisarg (if static?
		      #f
		      (if (pair? args)
			  (car args)
			  (error "Method must have at least a this arg"
				 (unparse var)
				 (unparse value)))))
	 (realargs (if static?
		       args
		       (cdr args))))
    (cond (keys
	   (let ((t (type-expression-value typeexp))
		 (n (or native
			(native-method-name (name var)))))
	     (let ((retval (last (body value))))
	       (unless (memq retval args)
		 (wire-type! (last (body value))
			     t)))
	     (unless static?
	       (wire-type! thisarg class-type)
	       (set (name thisarg) 'this))
	     (for-each (lambda (arg)
			 (unless (is? (type arg)
				      type-class)
			   (set (type arg)
				(type-expression-value (type arg)))))
		       realargs)
	     (set (native-name var) n)
	     (set (keywords var) keys)
	     (set (current-value var)
		  (if static?
		      (new native-procedure
			   (name var)
			   '()
			   #f
			   (string-append (native-name class-type)
					  "."
					  n))
		      (new method
			   n
			   keys
			   t)))))
	  (else
	   (let ((method-type (type var)))
	     (unless (is? method-type procedure-type)
	       (error "Method doesn't seem to be a procedure.  Did you forget to declare its keywords and type?"))
	     (wire-type! thisarg class-type)
	     (set (name thisarg) 'this)
	     (for-each (lambda (arg type)
			 (wire-type! arg type))
		       realargs
		       (cdr (arg-types method-type)))
	     (let ((retval (last (body value))))
	       (unless (memq retval args)
		 (wire-type! (last (body value))
			     (result method-type)))))))))

(define (prewire-field-types var native keys typeexp value class-type)
  (define static? (static-keys? keys))
  (cond (keys
	 (let ((t (type-expression-value typeexp))
	       (nam (name var))
	       (nat (native-field-name (name var))))
	   (set (keywords var) keys)
	   (set (type var)
		(if static?
		    t
		    (proc nam (class-type) t)))
	   (set (native-name var)
		(cond (native
		       native)
		      (static?
		       (string-append (native-name class-type)
				      "."
				      (or native nat)))
		      (else
		       nat)))
	   (set (current-value var)
		(new field (native-name var) t))))))

;;;;
;;;; PROPAGATORS FOR SPECIFIC EXPRESSION TYPES
;;;;

(define-method (propagate-types (exp expression))
  #f)

(define-method (propagate-types (m member-definition))
  (define method? (is? (value m) lambda-expression))

  (when method?
    (propagate-types (last (body (value m)))))
  (when (and (keywords m) method?)
    (set (type (var m))
	 (type (value m)))))

(define-method (propagate-types (exp set-expression))
  (bound-above! (rvalue exp)
		(type (lvalue exp))))

(define-method (propagate-types (exp conditional))
  (define c (consequent exp))
  (define a (alternative exp))

  (bound-above! (test exp) boolean-type)
  (bound-above! exp
		(if (null? a)
		    (type (consequent exp))
		    (type-lub (type c) (type a))))
  (let ((t (type exp)))
    (bound-above! c t)
    (unless (null? a)
      (bound-above! a t))))

(define-method (propagate-types (exp begin-expression))
  (equate-types! exp (last (body exp))))

(define-method (propagate-types (exp lambda-expression))
  ;(format #t "Return type is ~S~%" (type (last (body exp))))
  (set (type exp)
       (new-procedure-type simple-procedure-type
			   (type (last (body exp)))
			   (map type (variables exp)))))

(define-method (propagate-types (l let-expression))
  (equate-types! l  (last (body l)))
  (for-each (lambda (var)
	      (equate-types! var (initial-value var)))
	    (variables l)))

(define-method (propagate-types (l for-expression))
  (bound-above! l void-type)
  (bound-above! (test l) boolean-type)
  (for-each (lambda (var iterator)
	      (equate-types! var (initial-value var))
	      (equate-types! var iterator))
	    (variables l)
	    (iterators l)))

;(define-method (propagate-types (d definition))
;  (define t (type (initial-value (var d))))
;  (set (type (var d)) t)
;  (set (type d) t)) 

(define-method (propagate-types (t the-expression))
  (equate-types! t (exp t)))

(define-method (propagate-types (t cast-expression))
  #f)

;;;;
;;;; TYPE PROPAGATION THROUGH APPLICATIONS
;;;;

(define-method (propagate-types (exp application))
  (let* ((op (operator exp))
	 (ot (type op)))
    (cond ((eq? op the-array-var)
	   (bound-above! exp type-type))
	  ((and (is? op global-variable)
		(not (current-value op)))
	   (error "Call to unknown procedure" (unparse exp)))
	  (else
	   (if (eq? ot type-type)
	       (propagate-constructor exp)
	       (let ((t (type (operator exp))))
		 (when (is? t operoid-type)
		   (propagate (type (operator exp))
			      exp
			      (arguments exp)))))))))

(define (propagate-constructor exp)
  (let ((t (current-value (operator exp))))
    (unless (eq? t void-type)
      (let ((constructor-types (constructor-arg-types t))
	    (args (arguments exp)))
	(unless (= (length constructor-types)
		   (length args))
	  (error "Wrong number of arguments to constructor"
		 (unparse exp)
		 constructor-types))
	(for-each bound-above! args constructor-types)))
    (wire-type! exp t)))

(define-method (propagate (proc-type procedure-type) exp args)
  (bound-arg-types proc-type exp args)
  (bound-above! exp
		(result-type proc-type
			     (map type args))))

(define-method (propagate (nt new-operator-type) exp args)
  (if (null? args)
      (error "New operator requires at least a type argument"
	     (unparse exp))
      (let ((constructee (type-expression-value (car args)))
	    (constructor-args (cdr args)))
	(wire-type! exp constructee)
	(let ((arg-types (constructor-arg-types constructee)))
	  (unless (= (length arg-types)
		     (length constructor-args))
	    (error "Wrong number of arguments for constructor"
		   (unparse exp)
		   arg-types))
	  (for-each bound-above!
		    constructor-args
		    arg-types)))))

(define-method (propagate (na new-array-operator-type) exp args)
  (if (>= (length args) 2)
      (let ((constructee (type-expression-value (car args))))
	(wire-type! exp (array-type-of constructee))
	(bound-above! (cadr args) integer-type)
	(for-each (lambda (arg)
		    (bound-above! arg constructee))
		  (cddr args)))
      (error "Wrong number of arguments"
	     (unparse exp)
	     '(type length))))

(define-method (result-type (vrt vector-ref-type) arg-types)
  (unless (= (length arg-types)
	     2)
    (error "Wrong number of arguments to vector-ref" arg-types))
  (let ((array-arg (car arg-types)))
    (if (is? array-arg array-type-class)
	(base-type array-arg)
	object-type)))

(define-method (bound-arg-types (vrt vector-ref-type) exp args)
  (unless (= (length args)
	     2)
    (error "Wrong number of arguments to vector-ref"
	   (map unparse args)))
  (bound-above! (second args) integer-type))

(define-method (propagate (aot as-operator-type) exp args)
  (unless (= (length args)
	     2)
    (error "Wrong number of arguments to as" args))
  (bound-above! exp
		(type-expression-value (second args))))

;;;;
;;;; BASIC PROPAGATION MECHANISM
;;;;

(define (bound-above! exp t)
  (define old-type (type exp))
  (unless (type-wired? exp)
    (cond ((eq? old-type t))		;fast path
	  ((eq? old-type void-type))

	  ((or (eq? t void-type)
	       (type-<=? t old-type))
	   (set (type exp) t)
	   (propagate-types exp)
	   (for-each propagate-types (uses exp)))

	  ((type-<=? old-type t))
	  (else
	   (error "Expression used in contexts that require two different incompatible types"
		  (unparse exp)
		  old-type
		  t)))))

(define (equate-types! e1 e2)
  (bound-above! e1 (type e2))
  (bound-above! e2 (type e1)))

(define (wire-type! e t)
  (if (and (is? e local-variable)
	   (eq? (name e) 'elements)
	   (eq? t object-type))
      (break))
  (set (type e) t)
  (set (type-wired? e) #t))
;  (let ((old-type (type e)))
;    (set (type e) t)
;    (set (type-wired? e) #t)
;    (when (type-<=? t old-type)
;      (for-each propagate-types (uses e)))))
